Random Game Generator:
Housing Market Problem

Quit[];

Clear[R];
total=1000;cup=30;cap=70; lim1=2;lim2=5;
Print["Randomly generating Game with ", ToString[total], " players"];
Print["with the number of preference sets varying between ",ToString[lim1]," and ", ToString[lim2]];
Print["with the number of houses in a preference set varying between ", ToString[cup]," and ", ToString[cap]];
S={};
Monitor[
Do[
S=Append[S,ToExpression["a"<>ToString[i]]];
,{i,total}];,total-i];
Monitor[
Do[
y=Complement[S,{S[[i]]}];
XX={};
t=0;
rand2=RandomChoice[Range[lim1,lim2]];
Do[
If[t==rand2,Break[]];
rand=RandomChoice[Range[cup,cap]];
X=Union[RandomChoice[y,rand]];
XX=Append[XX,X];
y=Complement[y,X];
If[y=={},Break[]];

t++;
,{total}];
R[S[[i]]]=XX;
,{i,Count[S,x_]}];
,Count[S,x_]-i];

?R

Descending Value Serial Dictatorship

Rlist2={};
Print["Creating psi-worth function"];
Monitor[
t=0;
Do[
If[t<Count[R[ToExpression["a"<>ToString[i]]],x_],
t=Count[R[ToExpression["a"<>ToString[i]]],x_]]
,{i,Count[S,x_]}];

Do[
x=R[ToExpression["a"<>ToString[i]]];
Do[
If[Count[x,x_]==t,
Rlist2=Append[Rlist2,x];
Break[],
x=Append[x,{}]
]
,{t}],
{i,Count[S,x_]}];
,Count[S,x_]-i]
Clear[x,r];
x=t-1;
r={1};
Do[
r=Append[r,r[[ Count[r,x_]]]*(Apply[Plus,Map[Count[#[[x]],x_]&,Rlist2],{0}]+1)];
x--;
If[x==0,Break[]], {t}];
r=Sort[r,Greater];
(*we create the psi worth functions above*)
PsiList={};OrganizerList={};
Print["Placing psi-worth on each player"];
Monitor[
Do[
psi=0;
Do[
i=Position[R[S[[s]]],S[[j]]];
If[
i=={},
ii=0,
ii=r[[i[[1]][[1]]]]];
psi=psi+ii;
,{s,Count[S,x_]}];
PsiList=Append[PsiList,List[S[[j]],psi]];
OrganizerList=Append[OrganizerList,psi];
,{j,Count[S,x_]}];
,Count[S,x_]-j]
(*above, we put the psi worth on each player*)

SerialOrdering=Map[Transpose[PsiList][[1]][[#]]&,DeleteDuplicates[Flatten[Map[Flatten[Position[Transpose[PsiList][[2]],#]]&,Sort[OrganizerList,Greater]]]]];
PsiOrdering=Map[List[Transpose[PsiList][[1]][[#]],Transpose[PsiList][[2]][[#]]]&,DeleteDuplicates[Flatten[Map[Flatten[Position[Transpose[PsiList][[2]],#]]&,Sort[OrganizerList,Greater]]]]];

L=Sort[Union[Transpose[PsiOrdering][[2]]],Greater];
SerialOrdering2=Map[DeleteCases[Flatten[Cases[PsiOrdering,{x_,#}]],_Integer]&,L];

Print["Determining Randomization Patterns"];
X=Map[PsiList[[Flatten[Position[PsiList,#]][[1]]]]&,SerialOrdering];
Llist={};
Monitor[
Do[
Llist2={};
x=Complement[Range[Count[PsiList,x_]],Range[i]];
y=Map[PsiOrdering[[i]][[2]]-#≤r[[1]]&,Map[PsiOrdering[[#]][[2]]&,x]];
x=Map[x[[#]]&,Flatten[Position[y,True]]];
Do[
If[X[[i]][[2]]-X[[j]][[2]]≤r[[1]]
+If[Flatten[Position[R[SerialOrdering[[j]]],SerialOrdering[[i]]]]=={},0,
r[[Flatten[Position[R[SerialOrdering[[j]]],SerialOrdering[[i]]]][[1]]]]]
-If[Flatten[Position[R[SerialOrdering[[i]]],SerialOrdering[[j]]]]=={},0,
r[[Flatten[Position[R[SerialOrdering[[i]]],SerialOrdering[[j]]]][[1]]]]]
(*Here is the new change*)
,
Llist2=Union[Append[Llist2,Sort[{i,j}]]]
];
,{j,x}];
Llist=Union[Llist,Llist2];
,{i,Count[PsiList,x_]}]
,{Count[PsiList,x_]-i,Count[Llist,x_]}];
Slist=SerialOrdering;
Lnumber=Count[Union[Map[#[[1]]&,Llist]],x_];


(*We have the serial ordering for the algorithm*)

(*We now begin our do-loop to find optimal solutions*)
track=0;Xlist={}; time=0;
Print["Setting up Algorithm"];

Monitor[
Do[

RandomList=Slist;
yt=0;
Do[
x=RandomChoice[Append[Cases[Llist,{y,_}],{y,y}]];
RandomList=ReplacePart[RandomList,{x[[1]]->RandomList[[x[[2]]]],x[[2]]->RandomList[[x[[1]]]]}];
yt++;
,{y,Count[Union[Map[#[[1]]&,Llist]],x_]}];

SerialOrdering=RandomList;
ttt=SerialOrdering;
L={};
Do[
L=Append[L,Map[If[#>Count[R[SerialOrdering[[i]]],x_],{},R[SerialOrdering[[i]]][[#]]]
&,Range[lim2]]],{i,Count[SerialOrdering,x_]}];
rr={};
t=1;
Do[
rr=Append[rr,t];
t=t*Apply[LCM,DeleteCases[Union[Map[Count[#,x_]&,Map[#[[i]]&,L]]],0]];

,{i,lim2}];
Print["Creating Matrix"];
FMatrix={};
Do[
M={};
Do[
If[MemberQ[Flatten[R[SerialOrdering[[j]]]],SerialOrdering[[i]]],
M=Append[M,
 r[[Flatten[Position[R[SerialOrdering[[j]]],SerialOrdering[[i]]]][[1]]]] 

],
M=Append[M,0]],{i,Count[SerialOrdering,x_]}];
FMatrix=Append[FMatrix,M];
,{j,Count[SerialOrdering,x_]}];
Print["Creating Psi-Worth Function Modification"];
FMatrix=Transpose[FMatrix];
PsiOrdering2={};
Do[
PsiOrdering2=Append[PsiOrdering2,{SerialOrdering[[i]],Apply[Plus,FMatrix[[i]]]}]
,{i,Count[SerialOrdering,x_]}];
FMatrix=Transpose[FMatrix];
Print["Finding Optimal Solutions"];
Clear[x];
Unassigned={};
Label[here];
time++;
SerialList={};
Assigned={};
Alist={};
Do[
Alist=Append[Alist,0];
,{Count[S,x_]}];
Do[
If[DeleteCases[Map[Complement[#,Union[Unassigned,Assigned]]&,R[SerialOrdering[[i]]]],{}]=={},
x=SerialOrdering[[i]],
(*x1 removes all assigned and unassinged players from preferences, and chooses highest preference set*)
x1=DeleteCases[Map[Complement[#,Union[Unassigned,Assigned]]&,R[SerialOrdering[[i]]]],{}][[1]];
(*x2 gives all of the psi-worths of available players*)
x2=Map[Cases[PsiOrdering2,{#,_}][[1]]&,x1];
(*x3 gives all of the past worths of available players*)
x3=Map[Alist[[#]]&,Map[Flatten[Position[SerialOrdering,#]][[1]]&,x1]];
(*y2 gives position of least future psi-worth*)
y2=Flatten[Position[Map[#[[2]]&,x2]-x3,Min[Map[#[[2]]&,x2]-x3]]][[1]];
x=x1[[y2]];

Assigned=Append[Assigned,x];

];
SerialList=Append[SerialList,List[SerialOrdering[[i]],x]];
Alist=Alist+FMatrix[[i]];

,{i,Count[SerialOrdering,x_]}];
If[Count[S,x_]-track/r[[1]]<Count[Unassigned,x_]+Count[DeleteCases[Map[Flatten[Position[R[#[[1]]],#[[2]]]][[1]]&,SerialList],1],x_]
,Goto[there]];
If[Unassigned≠ Flatten[Union[Append[Unassigned,Union[Flatten[Cases[SerialList,{x_,x_}]]]]]]
,
Unassigned=Flatten[Union[Append[Unassigned,Union[Flatten[Cases[SerialList,{x_,x_}]]]]]];
Goto[here]];

If[track<Apply[Plus,Cases[Map[r[[#]]&,Map[Flatten[Position[R[#[[1]]],#[[2]]]][[1]]&,SerialList]],_Integer]],
track=Apply[Plus,Cases[Map[r[[#]]&,Map[Flatten[Position[R[#[[1]]],#[[2]]]][[1]]&,SerialList]],_Integer]];
Xlist=List[Sort[SerialList]]];
If[track==Apply[Plus,Cases[Map[r[[#]]&,Map[Flatten[Position[R[#[[1]]],#[[2]]]][[1]]&,SerialList]],_Integer]],
Xlist=Union[Append[Xlist,Sort[SerialList]]]];
Label[there];
;
,{1}],List[time,{i,i-Count[Assigned,x_]},j,y]];
Print["The Assigned are as follows: ",
Map[Count[Map[Flatten[Position[R[#[[1]]],#[[2]]]][[1]]&,Xlist[[1]]],#]&,Range[lim2]]];
Print["The number of unassigned are: ",Count[S,x_]-Apply[Plus,Map[Count[Map[Flatten[Position[R[#[[1]]],#[[2]]]][[1]]&,Xlist[[1]]],#]&,Range[lim2]]]];
Print["Time used is ",ToString[TimeUsed[]], " seconds"];
GraphPlot[Apply[Rule,Xlist[[1]],{1}],VertexLabeling->True,DirectedEdges->True]